home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 011 / autodesk.arc / 3DARRAY.LSP < prev    next >
Encoding:
Text File  |  1987-04-29  |  8.7 KB  |  316 lines
  1. ;**************************** 3DARRAY.LSP ********************************
  2.  
  3. ;       By Simon Jones   Autodesk Ltd,London   March 1987
  4.  
  5. ;  Functions included:
  6. ;       1) Rectangular ARRAYS (rows, columns & levels)
  7. ;       2) Orthogonal Circular ARRAYS around either X or Y axis
  8. ;       3) Orthogonal ROTATION around either X or Y axis
  9.  
  10. ;  All are loaded by: (Load "3darray")
  11.  
  12. ;  And run by:
  13. ;       Command: 3darray
  14. ;       Command: Array/Rotate: (select appropriate command)
  15.  
  16. ;  NOTE: Only 3DFACES,3DLINES,LINES & SOLIDS will be edited with
  17. ;        POLAR ARRAYS and ROTATIONS all others will be ignored.
  18.  
  19. ;***********************************************************************
  20.  
  21. (vmon)
  22. (prompt "\nLoading. Please wait...")
  23. (terpri)
  24.  
  25. (defun MODES (a)
  26.    (setq MLST '())
  27.    (repeat (length a)
  28.       (setq MLST (append MLST (list (list (car a) (getvar (car a))))))
  29.       (setq a (cdr a)))
  30. )
  31.  
  32. (defun MODER ()
  33.    (repeat (length MLST)
  34.       (setvar (caar MLST) (cadar MLST))
  35.       (setq MLST (cdr MLST))
  36.    )
  37. )
  38.  
  39. (defun *ERROR* (st)
  40.   (moder)
  41.   (terpri)
  42.   (princ "\nError: ")
  43.   (princ st)
  44.   (princ)
  45. )
  46.  
  47. ;*************************** DTR ***************************
  48.  
  49. ;  Convert degrees to radians
  50. (defun DTR (a)
  51.   (* pi (/ a 180.0))
  52. )
  53.  
  54. ;************************** TURN ***************************
  55.  
  56.   ; Retrieve and rotate point around specified axis
  57.  
  58. (defun TURN (n / pt ip2 z38)
  59.           (setq pt (cdr (assoc n elist)))
  60.           (if (or
  61.                 (= (cdadr elist) "LINE")
  62.                 (= (cdadr elist) "SOLID")
  63.               )
  64.               (progn
  65.                 (setq z38 (cdr (assoc 38 elist)))
  66.                 (if (null z38) (setq z38 0))
  67.                 (setq pt (append pt (list z38)))
  68.               )
  69.           )
  70.           (if (= flag 0)          ;flag set by ORTH-AX
  71.               (setq ip2 (list (cadr pt) (caddr pt)))
  72.               (setq ip2 (list (car pt) (caddr pt)))
  73.           )
  74.           (setq ip2 (polar ip1
  75.                            (+ ang (angle ip1 ip2))
  76.                            (distance ip1 ip2)
  77.                     )
  78.           )
  79.           (if (= flag 0)
  80.               (list (car pt) (car ip2) (cadr ip2))
  81.               (list (car ip2) (cadr pt) (cadr ip2))
  82.           )
  83. )
  84.  
  85. ;************************* ORTH-AX *************************
  86.  
  87.    ; Define orthogonal axis of rotation
  88.  
  89. (defun ORTH-AX ()
  90.    (setvar "ORTHOMODE" 1)
  91.  
  92.      ; define base points
  93.    (initget (+ 1 16))
  94.    (setq bpt1 (getpoint "\nFirst point of rotationl axis: "))
  95.    (setvar "ELEVATION" (caddr bpt1))
  96.    (initget (+ 1 16))
  97.    (setq bpt2 (getpoint bpt1 "\nSecond point of rotational axis: "))
  98.  
  99.      ;set flag (1 = vertical  0 = horizontal)
  100.    (setq flag (abs (fix (sin (angle bpt1 bpt2)))))
  101.    (setq z (caddr bpt1))
  102. )
  103.  
  104. ;************************* FILTER **************************
  105.  
  106.   ; Filter 3DFACES, 3DLINES, LINES & SOLIDS of original
  107.   ; selection set to be rotated for polar arrays and rotations
  108.  
  109. (defun FILTER (/ e elist)
  110.    (setq e (ssname ss c))
  111.    (setq elist (entget e))
  112.    (cond ((eq (cdr (assoc 0 elist)) "3DFACE")
  113.           (command "3DFACE"
  114.                    (turn 10) (turn 11) (turn 12) (turn 13) ""
  115.           )
  116.           (ssadd e ss2)
  117.           (entmod (subst (assoc 8 elist)
  118.                          (assoc 8 (entget (entlast)))
  119.                          (entget (entlast))))
  120.          )
  121.          ((eq (cdr (assoc 0 elist)) "SOLID")
  122.           (command "3DFACE"
  123.                    (turn 10) (turn 11) (turn 13) (turn 12) ""
  124.           )
  125.           (ssadd e ss2)
  126.           (entmod (subst  (assoc 8 elist)
  127.                           (assoc 8 (entget (entlast)))
  128.                           (entget (entlast))))
  129.          )
  130.          ((or
  131.             (eq (cdr (assoc 0 elist)) "3DLINE")
  132.             (eq (cdr (assoc 0 elist)) "LINE")
  133.           )
  134.           (command "3DLINE"
  135.                    (turn 10) (turn 11) ""
  136.           )
  137.           (ssadd e ss2)
  138.           (entmod (subst (assoc 8 elist)
  139.                          (assoc 8 (entget (entlast)))
  140.                          (entget (entlast))))
  141.          )
  142.    )
  143.    (setq c (1+ c))
  144. )
  145.  
  146. ;***************************** P-ARRAY *********************
  147.  
  148.   ; Perform polar (circular) array around either X or Y axis
  149.  
  150. (defun P-ARRAY (/ n af as ang ss2)
  151.    (orth-ax) ; Define orthoganal axis
  152.    (setvar "BLIPMODE" 0)
  153.    (if (= flag 0)    ; Set imaginary base point
  154.        (setq ip1 (list (cadr bpt1) z))
  155.        (setq ip1 (list (car bpt1) z))
  156.    )
  157.  
  158.    ; Define number of items in array
  159.    (setq n nil)
  160.    (while (<= n 1)
  161.           (initget (+ 1 2 4))
  162.           (setq n (getint "\nNumber of items: "))
  163.           (if (= n 1)
  164.               (prompt "\nError: Value must be greater than 1")
  165.           )
  166.    )
  167.    (initget 2)
  168.    (setq af (getreal "\nAngle to fill <360>: "))
  169.    (if (= af nil) (setq af 360))
  170.    (setq af (dtr af))
  171.    (if (= (abs af) (* 2 pi))
  172.        (progn
  173.         (setq as (/ af n))
  174.         (setq af (- af as))
  175.        )
  176.        (setq as (/ af (1- n)))
  177.    )
  178.    (setq ang as)
  179.  
  180.    (while (<= (abs ang) (abs af))
  181.           (setq c 0)
  182.           (setq ss2 (ssadd))
  183.           (while (< c (sslength ss))
  184.                  (filter)
  185.           )
  186.           (setq ang (+ ang as))   ; increment roatationl angle
  187.    )
  188.  
  189.    (if (= (sslength ss2) 0)
  190.        (prompt "\nNo suitable entities found. ")
  191.    )
  192. )
  193.  
  194. ;***************************** 3DROTATE ********************
  195.  
  196. (defun 3drotate (/ c)
  197.    (orth-ax)   ; Define orthogonal axis
  198.                ;about which to rotate
  199.  
  200.    (setvar "BLIPMODE" 0)
  201.    (if (= flag 0)    ; Set imaginary base point
  202.        (setq ip1 (list (cadr bpt1) z))
  203.        (setq ip1 (list (car bpt1) z))
  204.    )
  205.    (initget (+ 1 2))
  206.    (setq ang (getangle "\nRotational angle: "))
  207.    (setq c 0)
  208.    (setq ss2 (ssadd))
  209.    (while (< c (sslength ss))
  210.           (filter)     ; filtering is necessary since only 3dfaces
  211.                        ;and lines can be drawn at an angle to the
  212.                        ;vertical axis
  213.    )
  214.  
  215.    ; Delete only the filtered entities of the original
  216.    ;selection set
  217.    (setvar "HIGHLIGHT" 0)
  218.    (if (/= (sslength ss2) 0)
  219.        (command "ERASE" ss2 "")
  220.        (prompt "\nNo suitable entities found. ")
  221.    )
  222. )
  223.  
  224.  
  225. ;****************************** R-ARRAY ********************
  226.  
  227. (defun R-ARRAY (/ flag nr nc nl e el c x y z)
  228.  
  229.    ; Set array parameters
  230.    (initget (+ 2 4))
  231.    (setq nr (getint "\nNumber of rows (---) <1>: "))
  232.    (if (null nr) (setq nr 1))
  233.    (initget (+ 2 4))
  234.    (setq nc (getint "\nNumber of columns (|||) <1>: "))
  235.    (if (null nc) (setq nc 1))
  236.    (initget (+ 1 2 4))
  237.    (setq nl (getint "\nNumber of levels (...): "))
  238.    (setvar "ORTHOMODE" 1)
  239.    (setvar "HIGHLIGHT" 0)
  240.    (setq flag 0)    ; Command style flag
  241.    (cond ((/= nr 1)
  242.           (initget (+ 1 2))
  243.           (setq y (getdist "\nDistance between rows: "))
  244.           (setq flag 1)
  245.          )
  246.    )
  247.    (cond ((/= nc 1)
  248.           (initget (+ 1 2))
  249.           (setq x (getdist "\nDistance between columns: "))
  250.           (setq flag (+ flag 2))
  251.          )
  252.    )
  253.    (cond  ((/= nl 1)
  254.            (initget (+ 1 2))
  255.            (setq z (getdist "\nDistance between levels: "))
  256.           )
  257.    )
  258.    (setvar "BLIPMODE" 0)
  259.  
  260.    (setq c 1)
  261.    (setq el (entlast))  ;Reference entity
  262.  
  263.    ; Copy the selected entities one level at a time
  264.    (while (< c nl)
  265.           (command "COPY" ss ""
  266.                           "0,0,0"
  267.                           (append (list 0 0) (list (* c z)))
  268.           )
  269.           (setq c (1+ c))
  270.    )
  271.  
  272.    (setq ss2 (ssadd))          ;create a new selection set
  273.    (setq e (entnext el))       ;of all the new entities since
  274.    (while e                    ;the reference entity.
  275.        (ssadd e ss2)
  276.        (setq e (entnext e))
  277.    )
  278.  
  279.    ; Array original selection set and copied entities
  280.    (cond
  281.      ((= flag 1) (command "ARRAY" ss ss2 "" "R" nr "1" y))
  282.      ((= flag 2) (command "ARRAY" ss ss2 "" "R" "1" nc x))
  283.      ((= flag 3) (command "ARRAY" ss ss2 "" "R" nr nc y x))
  284.    )
  285. )
  286.  
  287. ;***************************** MAIN PROGRAM ****************
  288.  
  289. (defun C:3DARRAY (/ xx c ss ss2 z bpt1 bpt2 ip1 flag ang)
  290.  
  291.    (modes '("elevation" "cmdecho" "blipmode" "highlight" "orthomode"))
  292.    (setvar "CMDECHO" 0)
  293.    (command "UNDO" "MARK")
  294.    (graphscr)
  295.  
  296.    (setq ss nil ss2 nil c 0)
  297.    (while  (null ss)  ; Ensure selection of entities
  298.            (setq ss (ssget))
  299.    )
  300.  
  301.    (initget "Array Rotate")
  302.    (setq xx (getkword "\n<Array>/Rotate: "))
  303.    ; Branch to specific function
  304.    (cond ((eq xx "Rotate")  (3drotate))
  305.          (T
  306.           (initget 1 "Rectangular Polar Circular")
  307.           (setq xx (getkword "\nRectangular or Polar array (R/P): "))
  308.           (cond ((eq xx "Rectangular") (r-array))
  309.                 (T (p-array))
  310.           )
  311.          )
  312.    )
  313.    (moder) ; Restore system variables
  314.    (princ)
  315. )
  316.